'##################################################
'###  Top Level (Get root Path from system env)
'##################################################
function GetEnv(envVarName)
	On Error Resume Next
	' 创建Shell对象并获取值
	Set WshShell = CreateObject("WScript.Shell")
	envValue = WshShell.Environment("PROCESS")(envVarName) ' 优先查找进程级变量

	' 如果未找到则尝试系统级变量
	If Err.Number <> 0 Or envValue = "" Then
		Err.Clear
		envValue = WshShell.Environment("SYSTEM")(envVarName)
	End If

	' 如果仍未找到则尝试用户级变量
	If Err.Number <> 0 Or envValue = "" Then
		Err.Clear
		envValue = WshShell.Environment("USER")(envVarName)
	End If

	' 检查结果并输出
	If Err.Number = 0 And envValue <> "" Then
		GetEnv=envValue
	Else
		GetEnv=""
	End If
end function

'##################################################
'##################################################
'##################################################
sub IncludeVbs(filepath)
	Dim fso, file, content
	Set fso = CreateObject("Scripting.FileSystemObject")
	' 读取functions.vbs的内容
	Set file = fso.OpenTextFile(filepath, 1) ' 1表示只读
	content = file.ReadAll
	file.Close
	' 将functions.vbs的内容载入全局作用域
	ExecuteGlobal content
end sub

'##################################################
'##################################################
'##################################################
Dim doc
Set doc = application.ActiveDocument
dim TargetNet
Dim outputString

main
set doc = nothing
sub main()	
	'// REUSE
	envVarName ="EXP_SHORTCUTS_ROOT"
	dim root:root = GetEnv(envVarName)'"C:\MentorGraphics\2005EXP\SDD_HOME\pvtk\env\"
	if root ="" then 
		msgbox "please set env value (EXP_SHORTCUTS_ROOT = ?)"
		exit sub
	end if
	
	call IncludeVbs(root & "\skill_lib.vbs")
	
	If ValidateServer(doc) = 0 Then
	    msgbox "Server validation failed."
	    exit sub
	End If	
	
	'// TODO
	Call AddAppTypeLib
	Set TargetNet = nothing
	UpdateTargetNet
	if TargetNet is nothing then
		GetTargetNet
		if TargetNet is nothing then exit sub
		Call PlaneToConductive
		Call ConductiveToPlaneshape	
	else
		call ChangePlaneShapeNetByObject
		call ChangeConductiveShapeNetByObject
	end if
end sub
Sub AddAppTypeLib
	Dim AppName, AppFld
	AppName = application.Name
	AppFld = Split(AppName, " ")

	If AppFld(0) = "Board" Then
		Scripting.AddTypeLibrary("MGCPCB.BoardStationREApplication")
		End If
	If AppFld(0) = "Expedition" Then
		Scripting.AddTypeLibrary("MGCPCB.ExpeditionPCBApplication")
		End If
End Sub
sub UpdateTargetNet()	
	dim pcbPin,pcbTrace,pcbVia,pcbNet
	dim pcbPins,pcbTraces,pcbVias,pcbNets
	' Collect Selected Objects
	Set pcbPins = doc.Pins(1)
	Set pcbTraces = doc.Traces(1)
	Set pcbVias = doc.Vias(1)
	Set pcbNets = doc.Nets(1)
	
	dim selnet
	If pcbPins.Count = 0 And pcbTraces.Count = 0 And pcbVias.Count = 0 And pcbNets.Count = 0 Then
		outputString = "No Selected Object." & vbCrlf & "Select either Pin/Trace/Via or Net."
		application.Gui.Display outputString
		Exit sub
	End If

	For Each pcbPin In pcbPins
		selnet = pcbPin.Net.Name
		Set TargetNet = doc.FindNet(selnet)
		exit sub
	Next

	For Each pcbTrace In pcbTraces		
		selnet = pcbTrace.Net.Name
		Set TargetNet = doc.FindNet(selnet)
		exit sub
	Next

	For Each pcbVia In pcbVias		
		selnet = pcbVia.Net.Name
		Set TargetNet = doc.FindNet(selnet)
		exit sub
	Next	
end sub

sub GetTargetNet()
	Dim pcbNets, pcbNet
	Set pcbNets = doc.Nets(1)	
	For each pcbNet In pcbNets
		Set Targetnet = doc.FindNet(pcbNet.Name)
		exit for
	Next
end sub
Sub PlaneToConductive()
	On Error Resume Next
	Dim obs
	Set obs = doc.PlaneShapes(1, 0)
	If obs.Count = 0 Then Exit Sub
	dim ob
	Dim obNet, obLayer
	Dim numPoints, PntsArr
	For Each ob In obs
		PntsArr = ob.Geometry.PointsArray
		obLayer = ob.Layer + 1 - 1
		obLayer = doc.Gui.ActiveRouteLayer 
		ob.Delete    
		numPoints = UBound(PntsArr,2) + 1
		' Replace Shapes
	
		doc.TransactionStart(2)
		call doc.PutConductiveArea(obLayer,Targetnet,numPoints,PntsArr,Nothing,epcbAnchorNone, epcbUnitCurrent)												
		doc.TransactionEnd(1)
	Next	
End Sub

Sub ConductiveToPlaneshape()	
	On Error Resume Next
	Dim obs
	Set obs = doc.ConductiveAreas(1, 0)
	If obs.Count = 0 Then Exit Sub
	dim ob
	Dim obNet, obLayer
	Dim numPoints, PntsArr
	For Each ob In obs
		PntsArr = ob.Geometry.PointsArray
		obLayer = ob.Layer + 1 - 1
		obLayer = doc.Gui.ActiveRouteLayer 
		ob.Delete    
		numPoints = UBound(PntsArr,2) + 1
		' Replace Conductive Shapes
		doc.TransactionStart(2)
		call doc.PutPlaneShape(obLayer,numPoints,PntsArr,Targetnet,False,,,,Nothing,epcbUnitCurrent)
		doc.TransactionEnd(1)
	Next
End Sub

Sub ChangePlaneShapeNetByObject
	On Error Resume Next
	dim obs
	Set obs = doc.PlaneShapes(1, 0)
	If obs.Count = 0 Then exit sub
	
	dim ob
	dim PntsArr,numPoints
	dim oLyr
	dim HatchDistance,HatchPattern,HatchWidth	
	For Each ob In obs
		PntsArr = ob.Geometry.PointsArray
		numPoints = UBound(PntsArr,2) + 1
		oLyr = ob.Layer + 1 - 1
		
		HatchDistance = ob.HatchDistance
		HatchPattern = ob.HatchPattern
		HatchWidth = ob.HatchWidth
		ob.Delete	
		' Replace Shapes
		doc.TransactionStart(2)
		call doc.PutPlaneShape(oLyr,_
										numPoints,PntsArr,_
										TargetNet,_
										False,_
										HatchPattern,_
										HatchWidth,_
										HatchDistance,_
										Nothing,_
										epcbUnitCurrent)
		doc.TransactionEnd(1)
	Next
End Sub

Sub ChangeConductiveShapeNetByObject
	On Error Resume Next
	dim obs
	Set obs = doc.ConductiveAreas(1, 0)
	If obs.Count = 0 Then exit sub
	
	dim ob
	dim PntsArr,numPoints
	dim oLyr	
	For Each ob In obs
		PntsArr = ob.Geometry.PointsArray
		numPoints = UBound(PntsArr,2) + 1
		oLyr = ob.Layer + 1 - 1		
		ob.Delete	
		' Replace Shapes
		doc.TransactionStart(2)
		call doc.PutConductiveArea(oLyr,_
								TargetNet,_
								numPoints,PntsArr,_
								Nothing,_
								epcbAnchorNone, epcbUnitCurrent)
		doc.TransactionEnd(1)
	Next
End Sub
